package ipinterfaces;

#########################################################################
#									#
# Name:	 	ipinterfaces.pm (Perl Module)				#
#									#
# Completed:	8th October, 2003.					#
#									#
# Updated:	27th March, 2005.					#
#									#
# Author:	Simon Edwards, Linuxha.net				#
#									#
# Arguments:	N/A							#
#									#
# Purpose:	This module contains a series of routines for 		#
# 		performing various checks and actions aimed at IPv4	#
# 		handling for the linuxha codebase.			#
#									#
# Limitations:	1 - Lots probably.					#
#									#
# Environment:	None.							#
#									#
# Exit Codes:	N/A							#
# 									#
# Version:	@(#)1.0.0 Original (SE)>				#
# 		@(#)1.0.1 Improved perl5.8 rc handling (SE)>		#
# 		@(#)1.0.3 Implement usesrcaddr in ip_check (SE)>	#
# 		@(#)1.0.4 balence typo fix! (SE)>			#
# 		@(#)1.0.5 Support gathering for bonded interfaces (SE)>	#
# 		@(#)1.0.6 Changes for DRBD support (SE)>		#
# 		@(#)1.0.8 Use miitoollib for link checking (SE)>	#
# 		@(#)1.0.9 Support broadcast - 0162 (SE)>		#
# 		@(#)1.1.0 Support 0109 changes (multiple ips) (SE)>	#
# 		@(#)1.1.1 Fixes for 0181 bug (ammar.ammar@ls-d.de)>	#
# 		@(#)1.1.2 Get rid of debug print out (SE)>		#
# 		@(#)1.1.3 Added set_routes and get_routes (SE)>		#
# 		@(#)1.1.4 Final changes to fix 0202 (SE)>		#
# 		@(#)1.1.5 Fix to bug 0208 (SE)>				#
# 		@(#)1.1.6 Implement improvement 0193 (SE)>		#
# 		@(#)1.1.7 Make changes for improvement 0213 (SE)>	#
# 		@(#)1.1.8 Implement changes for 0217 (SE)>		#
# 		@(#)1.2.0 have_link updated to use ethtoolquery (SE)>	#
# 		@(#)1.2.1 have_link returns check type 0233 (SE)>	#
#									#
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
#									#
# Complete SOCM Version History						#
#									#
# Version:	1.0.2							#
# Date:		9th April, 2004.					#
# Author:	Simon Edwards, Proprius Consulting Ltd.			#
# Change:	Implemented the balance option in the choose_interface	#
# 		method to balance IP allocation over the available	#
# 		interfaces.						#
# 									#
# Version:	1.0.3							#
# Date:		22nd May, 2004.						#
# Author:	Simon Edwards, Proprius Consulting Ltd.			#
# Change:	Added the optional usesrcaddr option to the ip_check	#
# 		routine to specify the name of a card to bind the	#
# 		IP checks to - this is optional however.		#
#									#
# Version:	1.0.8							#
# Date:		6th January, 2005.					#
# Author:	Simon Edwards, Linuxha.net				#
# Change:	If the miitoollib has been successfully installed then	#
#		use that instead of mii-diag for physical link		#
#		level checking.						#
#########################################################################

BEGIN {
        push @INC,"/usr/local/cluster/lib/perl";
}

use Net::Ping;
eval { require "miitoollib.pm"; } ;
eval "use Net::Interface;" ;

# Can take remote=>node to get details via ssh of remote node.

sub new {
my $proto=shift;
my $class=ref($proto) || $proto;
my $self={};
my %args=@_;

	#################################################################
	# Required, since have_link might use either, unless forced	#
	# to use a certain one.						#
	#################################################################
	$self->{MIITOOLLIB}=0;
	$self->{ETHTOOLLIB}=0;
	if(defined(&miitoollib::ethtoolquery)) {
		$self->{ETHTOOLLIB}=1;
	}
	if(defined(&miitoollib::miiquery)) {
		$self->{MIITOOLLIB}=1;
	}
	$self->{MIITOOLLIB_SEND_ARP}=defined(&miitoollib::send_arp);
	if(exists($args{remote})) {
		$self->{remote}=$args{remote};
	}
        eval '@F=Net::Interface->interfaces;';
	if(defined($F[0])) {
		$self->{NET_INTERFACES}=1;
	} else {
		$self->{NET_INTERFACES}=0;
	}
	bless($self,$class);
	return $self;
}

sub scan_interfaces {
my $self=shift;
my (%interfaces,$fd,$cint,$no,$int);
my ($ip,$bcast,$mask,$hw);

	%interfaces=();
	$self->{scantime}=time;
	if($self->{NET_INTERFACES} && !exists($self->{remote})) {
		my (@F,$MAC,$i);
		foreach $int (Net::Interface->interfaces ()) {
			$cint=$int->name;
			next if $cint eq "lo";
			if($cint !~ /:/) {
				$cint.=":0";
			}
			$interfaces{"$cint"}->{ip}=join(".", unpack("C*", $int->address));
			$interfaces{"$cint"}->{broadcast}=join(".", unpack("C*", $int->broadcast));
			$interfaces{"$cint"}->{netmask}=join(".", unpack("C*", $int->netmask));
			$interfaces{"$cint"}->{network}=_return_network($interfaces{"$cint"}->{ip},
								$interfaces{"$cint"}->{netmask});
			$MAC="";
			@F = split('', uc(unpack("H*", $int->hwaddress)));
			for($i=0;$i<scalar @F;$i+=2){
				$MAC.=($i+2<scalar @F ? "$F[$i]$F[$i+1]:" : "$F[$i]$F[$i+1]");
			}

			$interfaces{"$cint"}->{mac}=$MAC;
			$interfaces{"$cint"}->{slave}=0;
		}
		$self->{interfaces}=\%interfaces;
		return;
	}
	$cmd="ifconfig -a";
	if($self->{remote}) {
		$cmd="ssh ".$self->{remote}." $cmd";
	}
	if(!open($fd,"$cmd|")) {
		$self->{interfaces}={};
		return;
	}

	#################################################################
	# We are only interested in ethernet interfaces, so avoid	#
	# getting information on anything else as yet.			#
	# 1.0.5:							#
	# Though gather bonding interface info as well...		#
	#################################################################

	while(<$fd>) {
		if(/^[a-z]+/) {
			$cint=undef;
			next if ! /^eth[0-9]+/ && ! /^bond[0-9]+/;
			if(/^(eth[0-9]+):([0-9]+)\s+/) {
				($cint,$no)=($1,$2);
			} elsif(/^(bond[0-9]+)\s+/) {
		       		$cint=$1;
				$no=0;
			} else {
				($cint)=(/^([a-z0-9]+)/);
				$no=0;
			}

			next if ! defined $cint;
			$interfaces{"$cint:$no"}={};
			($hw)=(/HWaddr\s+([A-F0-9:]+)/);
			if(defined($hw)) {
				$interfaces{"$cint:$no"}->{mac}=$hw;
			}
			$interfaces{"$cint:$no"}->{slave}=0;
			next;
		} else {
			next if !defined($cint);
		}
		if(/inet addr/) {
			($ip,$bcast,$mask)=(/inet addr:([0-9\.]+)\s+Bcast:([0-9\.]+)\s+Mask:([0-9\.]+)/);
			$interfaces{"$cint:$no"}->{ip}=$ip if defined($ip);
			$interfaces{"$cint:$no"}->{broadcast}=$bcast if defined($bcast);
			$interfaces{"$cint:$no"}->{netmask}=$mask if defined($mask);
			if(defined($ip) && defined($mask)) {
				$interfaces{"$cint:$no"}->{network}=_return_network($ip,$mask);
			}
		}
		if(/UP\s+/) {
			$interfaces{"$cint:$no"}->{up}=1;
		}
		if(/SLAVE\s+/) {
			$interfaces{"$cint:$no"}->{slave}=1;
		}
	}
	$self->{interfaces}=\%interfaces;
	close($fd);
}

#########################################################################
# This will return a list of physical or logical interfaces names	#
# Must use logical => 1 or physical => 1				#
#########################################################################

sub list {
my $self=shift;
my @nlist;
my %args=@_;

	if(!exists($self->{scantime})) {
		$self->{scantime}=0;
	}
	if(!exists($args{logical}) && !exists($args{physical})) {
		return undef;
	}
	if(exists($args{all})) {
		my ($fd,$cline);
		@nlist=();
		open($fd,"/proc/net/dev");
		$cline=<$fd>;
		$cline=<$fd>;
		while($cline=<$fd>) {
			chomp $fd;
			($cc)=($cline =~ /^\s*eth([0-9]+):/);
			if(defined($cc)) {
				push @nlist,"eth$cc";
			}
		}
		close($fd);
		return @nlist;
	}
	if(exists($args{always})) {
		scan_interfaces($self);
	} elsif($self->{scantime}+30<time) {
		scan_interfaces($self);
	}
	@nlist=();
	if(!exists($args{logical})) {
		foreach (keys %{$self->{interfaces}}) {
			if(/(.*):0$/) {
				push @nlist,$1;
			}
		}
	} else {
		foreach (keys %{$self->{interfaces}}) {
			if(/(.*):0$/) {
				push @nlist,$1;
			} else {
				push @nlist,$_;
			}
		}
	}
	return @nlist;
}

#########################################################################
# Given an interface it will return the number of the next logical	#
# interface that can be assigned to.					#
#########################################################################

sub get_logical {
my $self=shift;
my %args=@_;
my ($int,$try);

	if(!exists($self->{scantime})) {
		$self->{scantime}=0;
	}
	if(!exists($args{interface})) {
		return -1;
	}
	if(exists($args{always})) {
		scan_interfaces($self);
	} elsif($self->{scantime}+30<time) {
		scan_interfaces($self);
	}

	$int=$args{interface};
	if(!exists($self->{interfaces}->{"$int:0"})) {
		return -2;
	}
	$try=1;
	while(exists($self->{interfaces}->{"$int:$try"})) {
		$try++;
	}
	return $try;
}

#########################################################################
# Given an IP address this will return the $cint:$no of the		#
# interface, or undef if no such ip address is currently assigned.	#
#########################################################################

sub get_interface {
my $self=shift;
my %args=@_;
my @d;

	#################################################################
	# 0109: Put a check here to see if multiple IP addresses	#
	#	have been passed and issue a warning if so...		#
	#################################################################
	@d=split(/,/,$args{ip});
	if(scalar(@d)>1) {
		print STDERR "GET_INTERFACE: Multiple IPs passed!\n";
		$args{ip}=(split(/,/,$args{ip}))[0];
	}

	if(!exists($self->{scantime})) {
		$self->{scantime}=0;
	}
	if(!exists($args{ip})) {
		return undef;
	}
	if(exists($args{always})) {
		scan_interfaces($self);
	} elsif($self->{scantime}+30<time) {
		scan_interfaces($self);
	}
	foreach (keys %{$self->{interfaces}}) {
		next if ! exists($self->{interfaces}->{$_}->{ip});
		next if ! defined($self->{interfaces}->{$_}->{ip});
		if($self->{interfaces}->{$_}->{ip} eq $args{ip}) {
			return $_;
		}
	}
	return undef;
}

#########################################################################
# The following routine takes an interface and checks to see if it	#
# has linked connectivity. It expects to have the following flags:	#
# interface, [always]							#
# Note:	If the interface is virtual (eth2:1) it will converted to the	#
# physical (eth2).							#
# Return codes are as follows:						#
# 1 - link beat ok							#
# 0 - no link beat							#
# 2 - link beat detection not supported on this interface		#
# -1 - missing / invalid argument					#
# 3 - no such interface exists						#
#########################################################################

sub have_link {
my $self=shift;
my %args=@_;
my ($interface,$phys,$log,$rc,$r);
my $method;

	$method=$args{method} if defined($args{method});
	if(!exists($self->{scantime})) {
		$self->{scantime}=0;
	}
	if(!exists($args{interface})) {
		return (-1,"Missing arg");
	}
	if(!defined($args{interface})) {
		return (-1,"Undefined arg");
	}
	$interface=$args{interface};

	if(exists($args{always})) {
		scan_interfaces($self);
	} elsif($self->{scantime}+60<time) {
		scan_interfaces($self);
	}

	if($interface =~ /:/) {
		($phys,$log)=($interface =~ /(.*):(.*)/);
	} else {
		($phys,$log)=($interface,0);
	}

	if(!exists($self->{interfaces}->{"$phys:0"})) {
		return (3,"Physical interface $phys does not exist");
	}
	if(($self->{MIITOOLLIB}==0 && $self->{ETHTOOLLIB}==0) || 
		(defined($method) && $method eq "MIIDIAG")) {
		if(! -f "/sbin/cluster/mii-diag") {
			return (2,"Link beat not supported on $phys");
		}
		$r=`/sbin/cluster/mii-diag $phys 2>&1`;

	#################################################################
	# APPLICATION_RC is set by the SIGCHLD handler in the main	#
	# program, so check for that variable first...			#
	#################################################################
		if(defined($::APPLICATION_RC)) {
			$rc=$::APPLICATION_RC;
		} else {
			$rc=$?>>8;
		}
		if($r =~ /You have link beat/ || $r =~ /link ok/) {
			return (1,"Link beat OK","MIIDIAG");
		}
		if($r =~ /Operation not supported/) {
			return (2,"Link beat not supported on $phys");
		}
		return (0,"No link beat detected on interface $phys","MIIDIAG");
	} else {
		if(($self->{ETHTOOLLIB}==1 && !defined($method)) ||
			(defined($method) && $method eq "ETHTOOLLIB")) {
			$r=miitoollib::ethtoolquery($phys);
			return(0,"No link beat detected on interface $phys","ETHTOOLLIB") if !$r;
			return(1,"Link beat OK","ETHTOOLLIB") if $r==1;
		}
		#########################################################
		# If we get here ETHTOOLLIB not supported on specified	#
		# interface, so attempt to use the other one...		#
		#########################################################
		if(($self->{MIITOOLLIB}==1 && !defined($method)) ||
			(defined($method) && $method eq "MIITOOLLIB")) {
			$r=miitoollib::miiquery($phys);
			if($r =~ /You have link beat/ || $r =~ /link ok/) {
				return (1,"Link beat OK","MIITOOLLIB");
			}
			if($r !~ /Operation not supported/) {
				return (0,"No link beat detected on interface $phys","MIITOOLLIB");
			}
		}
		return(2,"Link beat not supported on $phys");
	}
}

#########################################################################
#									#
# This routine will take details of the IP information to ping and 	#
# will return the following:						#
# (1,results)	- IP interface is working as expected			#
# (0,results)	- Ping results below threshold, so might consider	#
# 		  moving the interface.					#
# (-1,str)	- Other error occured.					#
# 		  							#
# The following arguments are expected:					#
# 									#
# ips		- Optional list of ip addresses to try			#
# [succeed]	- Percentage of IP address over which the interface	#
# 		  is thought to be valid. Defaults to 100.		#
# [pingtype]	- Type of ping to use (defaults to udp).		#
# [pingtimeout]	- Timeout for ping (default to 2 seconds)		#
# [logmsg]	- Function to send log messages to.			#
# [logwarn]	- Function to send warn messages to.			#
# [usearp]	- Whether to send gratuitous arp when an IP address	#
#		  is assigned to an interface.				#
# [usesrcaddr]	- Bind the ping routine to the interface specified as	#
# 		  this variable.					#
#									#
#########################################################################

sub ip_check {
my $self=shift;
my %args=@_;
my ($ips,$succeed,$pingtype);
my ($cip,$count,$okcount,$str);
my ($pinger,$pingtimeout,$logmsg,$logwarn);
my ($srcaddr,$bindip);

	if(!exists($args{ips})) {
		return (-1,"Missing ip or interfaces argument");
	}
	if(!defined($args{ips})) {
		return (-1,"undefined ip or interfaces argument");
	}

	$ips=$args{ips};
	$succeed=$args{succeed} if exists($args{succeed});
	$pingtype=$args{pingtype} if exists($args{pingtype});
	$pingtimeout=$args{pingtimeout} if exists($args{pingtimeout});
	$logmsg=$args{logmsg} if exists($args{logmsg});
	$logwarn=$args{logwarn} if exists($args{logwarn});
	$succeed=100 if !defined($succeed);
	$pingtype="udp" if !defined($pingtype);
	$pingtimeout=2 if !defined($pingtimeout);

	if(exists($args{usesrcaddr})) {
		$srcaddr=$args{usesrcaddr};
		if(exists($self->{interfaces}->{"$srcaddr:0"}) &&
			exists($self->{interfaces}->{"$srcaddr:0"}->{ip})) {
				$bindip=$self->{interfaces}->{"$srcaddr:0"}->{ip};
		}
	}
	$count=0;
	$okcount=0;
	$pinger=Net::Ping->new($pingtype,$pingtimeout);

	#################################################################
	# We only attempt to perform the bind if the version of 	#
	# Net::Ping actually supports it - version 5.6.x do not.	#
	#################################################################

	if(defined($bindip)) {
		if(defined(&Net::Ping::bind)) {
			$pinger->bind($bindip);
		} else {
			&$logwarn("Bind method not available for Net::Ping!") if defined($logwarn);
		}
	}

	foreach $cip (split(/,/,$ips)) {
		$rc=$pinger->ping($cip);
		if($rc) {
			$okcount++;
		}
		$count++;
	}
	if($okcount/$count*100>=$succeed) {
		return (1,int($okcount/$count*100));
	} else {
		return (1,int($okcount/$count*100));
	}
}

#########################################################################
# Return the list of routes currently associated with a particular	#
# interface. It returns a list where each element is:			#
# IPDEST:GATEWAY:FLAGS:GENMASK						#
# eg: 192.168.0.0:0.0.0.0:U:255.255.255.0,0.0.0.0:192.168.0.1:UG	#
#									#
# Requires the following argument:					#
# interface:	The name of the interface to get the routes for -	#
#		such as eth0 - routine will strip of logical interface	#
#		information if passed.					#
#########################################################################

sub get_routes {
my $self=shift;
my %args=@_;
my (@l,@F,$cmd,$cline,$fd,$i);

	@l=();
	return() if !exists($args{interface});
	$i=$args{interface};
	$i =~ s/:.*//;
	$cmd="netstat -nr|";
	open($fd,$cmd) or return();
	while($cline=<$fd>) {
		chomp $cline;
		next if $cline !~ /^[0-9]{1,3}/;
		@F=split(/\s+/,$cline);
		next if $F[$#F] ne $i;
		push @l,"$F[0]:$F[1]:$F[3]:$F[2]";
	}
	close($fd);
	return @l;
}

#########################################################################
# set_routes takes the list of routines in the format generated by	#
# get_routes and applies them to a particular interface.		#
# Returns a list of any routes that could not be set.			#
# If the destination already exists on that interface a new one will	#
# not be set up.							#
# Requires the following arguments:					#
# interface	The name of the interface to set the routes up on.	#
# routes	A reference to a list of routes to configure.		#
#########################################################################

sub set_routes {
my $self=shift;
my %args=@_;
my (@r,$cmd,@F,@F2,@r2,$x,$f,$i,@b);

	@b=();
	die("Missing routes argument") if !exists($args{routes});
	@r=@{$args{routes}};
	die("Missing interface argument") if !exists($args{interface});
	$i=$args{interface};
	$i =~ s/:.*//;

	#################################################################
	# firstly get a list of current routes on the new interface.	#
	#################################################################

	@r2=get_routes($self,interface=>$i);

	for (@r) {
		@F=split(/:/,$_);
		#########################################################
		# Ensure this route is not already configured, and if	#
		# so we ignore it.					#
		#########################################################
		$f=0;
		for $x (@r2) {
			@F2=split(/:/,$x);
			if($F[0] eq $F2[0]) {
				$f=1;last;
			}
		}
		next if $f;
		# Route needs to be added, so attempt to do so.		#
		if($F[2] =~ /H/) {
			$cmd="/sbin/route add $F[0] ";
		} else {
			$cmd="/sbin/route add -net $F[0] ";
		}
		$cmd.="netmask $F[3] ";
		$cmd.="gw $F[1] " if $F[1] ne "0.0.0.0";
		$cmd.="dev $i 2>&1";

		$r=`$cmd`;
		chomp $r;
		if($r ne "") {
			push @b,$cmd;
		}
	}
	return @b;
}

sub _return_network {
my ($ipaddr,$netmask)=@_;
my (@a,@b,@c,$i);

	@a=split(/\./,$ipaddr);
	@b=split(/\./,$netmask);
	for($i=0;$i<4; $i++) {
		$c[$i]=int($a[$i]) & int($b[$i]);
	}
	return join(".",@c);
}

sub get_details {
my $self=shift;
my %args=@_;

	return(undef) if !exists($args{interface});
	return(undef) if !exists($self->{interfaces}->{$args{interface}});
	return $self->{interfaces}->{$args{interface}};
}

1;

